import qualified Data.Map as M
preCommitHook :: Git.Hook
-preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .") []
+preCommitHook = Git.Hook (literalOsPath "pre-commit")
+ (mkHookScript "git annex pre-commit .") []
postReceiveHook :: Git.Hook
-postReceiveHook = Git.Hook "post-receive"
+postReceiveHook = Git.Hook (literalOsPath "post-receive")
-- Only run git-annex post-receive when git-annex supports it,
-- to avoid failing if the repository with this hook is used
-- with an older version of git-annex.
]
postCheckoutHook :: Git.Hook
-postCheckoutHook = Git.Hook "post-checkout" smudgeHook []
+postCheckoutHook = Git.Hook (literalOsPath "post-checkout") smudgeHook []
postMergeHook :: Git.Hook
-postMergeHook = Git.Hook "post-merge" smudgeHook []
+postMergeHook = Git.Hook (literalOsPath "post-merge") smudgeHook []
-- Older versions of git-annex didn't support this command, but neither did
-- they support v7 repositories.
smudgeHook = mkHookScript "git annex smudge --update"
preCommitAnnexHook :: Git.Hook
-preCommitAnnexHook = Git.Hook "pre-commit-annex" "" []
+preCommitAnnexHook = Git.Hook (literalOsPath "pre-commit-annex") "" []
postUpdateAnnexHook :: Git.Hook
-postUpdateAnnexHook = Git.Hook "post-update-annex" "" []
+postUpdateAnnexHook = Git.Hook (literalOsPath "post-update-annex") "" []
preInitAnnexHook :: Git.Hook
-preInitAnnexHook = Git.Hook "pre-init-annex" "" []
+preInitAnnexHook = Git.Hook (literalOsPath "pre-init-annex") "" []
freezeContentAnnexHook :: Git.Hook
-freezeContentAnnexHook = Git.Hook "freezecontent-annex" "" []
+freezeContentAnnexHook = Git.Hook (literalOsPath "freezecontent-annex") "" []
thawContentAnnexHook :: Git.Hook
-thawContentAnnexHook = Git.Hook "thawcontent-annex" "" []
+thawContentAnnexHook = Git.Hook (literalOsPath "thawcontent-annex") "" []
secureEraseAnnexHook :: Git.Hook
-secureEraseAnnexHook = Git.Hook "secure-erase-annex" "" []
+secureEraseAnnexHook = Git.Hook (literalOsPath "secure-erase-annex") "" []
commitMessageAnnexHook :: Git.Hook
-commitMessageAnnexHook = Git.Hook "commitmessage-annex" "" []
+commitMessageAnnexHook = Git.Hook (literalOsPath "commitmessage-annex") "" []
httpHeadersAnnexHook :: Git.Hook
-httpHeadersAnnexHook = Git.Hook "http-headers-annex" "" []
+httpHeadersAnnexHook = Git.Hook (literalOsPath "http-headers-annex") "" []
mkHookScript :: String -> String
mkHookScript s = unlines
hookWarning h msg = do
r <- gitRepo
warning $ UnquotedString $
- fromRawFilePath (Git.hookName h) ++
- " hook (" ++ fromRawFilePath (Git.hookFile h r) ++ ") " ++ msg
+ fromOsPath (Git.hookName h) ++
+ " hook (" ++ fromOsPath (Git.hookFile h r) ++ ") " ++ msg
{- To avoid checking if the hook exists every time, the existing hooks
- are cached. -}
( return Nothing
, do
h <- fromRepo (Git.hookFile hook)
- commandfailed (fromRawFilePath h)
+ commandfailed (fromOsPath h)
)
runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case
Nothing -> return Nothing
)
commandfailed c = return $ Just c
-runAnnexPathHook :: String -> Git.Hook -> (GitConfig -> Maybe String) -> RawFilePath -> Annex Bool
+runAnnexPathHook :: String -> Git.Hook -> (GitConfig -> Maybe String) -> OsPath -> Annex Bool
runAnnexPathHook pathtoken hook commandcfg p = ifM (doesAnnexHookExist hook)
( runhook
, runcommandcfg
)
where
- runhook = inRepo $ Git.runHook boolSystem hook [ File (fromRawFilePath p) ]
+ runhook = inRepo $ Git.runHook boolSystem hook [ File p' ]
runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case
Nothing -> return True
Just basecmd -> liftIO $
boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
- gencmd = massReplace [ (pathtoken, shellEscape (fromRawFilePath p)) ]
+ gencmd = massReplace [ (pathtoken, shellEscape p') ]
+ p' = fromOsPath p
outputOfAnnexHook :: Git.Hook -> (GitConfig -> Maybe String) -> Annex (Maybe String)
outputOfAnnexHook hook commandcfg = ifM (doesAnnexHookExist hook)
withShared :: (SharedRepository -> Annex a) -> Annex a
withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig
-setAnnexFilePerm :: RawFilePath -> Annex ()
+setAnnexFilePerm :: OsPath -> Annex ()
setAnnexFilePerm = setAnnexPerm False
-setAnnexDirPerm :: RawFilePath -> Annex ()
+setAnnexDirPerm :: OsPath -> Annex ()
setAnnexDirPerm = setAnnexPerm True
{- Sets appropriate file mode for a file or directory in the annex,
- other than the content files and content directory. Normally,
- don't change the mode, but with core.sharedRepository set,
- allow the group to write, etc. -}
-setAnnexPerm :: Bool -> RawFilePath -> Annex ()
+setAnnexPerm :: Bool -> OsPath -> Annex ()
setAnnexPerm isdir file = setAnnexPerm' Nothing isdir >>= \go -> liftIO (go file)
-setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> Annex (RawFilePath -> IO ())
+setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> Annex (OsPath -> IO ())
setAnnexPerm' modef isdir = ifM crippledFileSystem
( return (const noop)
, withShared $ \s -> return $ \file -> go s file
Nothing -> noop
Just f -> void $ tryIO $
modifyFileMode file $ f []
- go (UmaskShared n) file = void $ tryIO $ R.setFileMode file $
- if isdir then umaskSharedDirectory n else n
+ go (UmaskShared n) file = void $ tryIO $
+ R.setFileMode (fromOsPath file) $
+ if isdir then umaskSharedDirectory n else n
modef' = fromMaybe addModes modef
-resetAnnexFilePerm :: RawFilePath -> Annex ()
+resetAnnexFilePerm :: OsPath -> Annex ()
resetAnnexFilePerm = resetAnnexPerm False
{- Like setAnnexPerm, but ignores the current mode of the file entirely,
- which is going to be moved to a non-temporary location and needs
- usual modes.
-}
-resetAnnexPerm :: Bool -> RawFilePath -> Annex ()
+resetAnnexPerm :: Bool -> OsPath -> Annex ()
resetAnnexPerm isdir file = unlessM crippledFileSystem $ do
defmode <- liftIO defaultFileMode
let modef moremodes _oldmode = addModes moremodes defmode
{- Creates a directory inside the gitAnnexDir (or possibly the dbdir),
- creating any parent directories up to and including the gitAnnexDir.
- Makes directories with appropriate permissions. -}
-createAnnexDirectory :: RawFilePath -> Annex ()
+createAnnexDirectory :: OsPath -> Annex ()
createAnnexDirectory dir = do
top <- parentDir <$> fromRepo gitAnnexDir
tops <- annexDbDir <$> Annex.getGitConfig >>= return . \case
createDirectoryUnder' tops dir createdir
where
createdir p = do
- liftIO $ R.createDirectory p
+ liftIO $ createDirectory p
setAnnexDirPerm p
{- Create a directory in the git work tree, creating any parent
-
- Uses default permissions.
-}
-createWorkTreeDirectory :: RawFilePath -> Annex ()
+createWorkTreeDirectory :: OsPath -> Annex ()
createWorkTreeDirectory dir = do
fromRepo repoWorkTree >>= liftIO . \case
Just wt -> createDirectoryUnder [wt] dir
- it should not normally have. checkContentWritePerm can detect when
- that happens with write permissions.
-}
-freezeContent :: RawFilePath -> Annex ()
+freezeContent :: OsPath -> Annex ()
freezeContent file =
withShared $ \sr -> freezeContent' sr file
-freezeContent' :: SharedRepository -> RawFilePath -> Annex ()
+freezeContent' :: SharedRepository -> OsPath -> Annex ()
freezeContent' sr file = freezeContent'' sr file =<< getVersion
-freezeContent'' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Annex ()
+freezeContent'' :: SharedRepository -> OsPath -> Maybe RepoVersion -> Annex ()
freezeContent'' sr file rv = do
- fastDebug "Annex.Perms" ("freezing content " ++ fromRawFilePath file)
+ fastDebug "Annex.Perms" ("freezing content " ++ fromOsPath file)
unlessM crippledFileSystem $ go sr
freezeHook file
where
- support removing write permissions, so when there is such a hook
- write permissions are ignored.
-}
-checkContentWritePerm :: RawFilePath -> Annex (Maybe Bool)
+checkContentWritePerm :: OsPath -> Annex (Maybe Bool)
checkContentWritePerm file = ifM crippledFileSystem
( return (Just True)
, do
liftIO $ checkContentWritePerm' sr file rv hasfreezehook
)
-checkContentWritePerm' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Bool -> IO (Maybe Bool)
+checkContentWritePerm' :: SharedRepository -> OsPath -> Maybe RepoVersion -> Bool -> IO (Maybe Bool)
checkContentWritePerm' sr file rv hasfreezehook
| hasfreezehook = return (Just True)
| otherwise = case sr of
| otherwise -> want sharedret
(\havemode -> havemode == removeModes writeModes n)
where
- want mk f = catchMaybeIO (fileMode <$> R.getFileStatus file)
+ want mk f = catchMaybeIO (fileMode <$> R.getFileStatus (fromOsPath file))
>>= return . \case
Just havemode -> mk (f havemode)
Nothing -> mk True
{- Allows writing to an annexed file that freezeContent was called on
- before. -}
-thawContent :: RawFilePath -> Annex ()
+thawContent :: OsPath -> Annex ()
thawContent file = withShared $ \sr -> thawContent' sr file
-thawContent' :: SharedRepository -> RawFilePath -> Annex ()
+thawContent' :: SharedRepository -> OsPath -> Annex ()
thawContent' sr file = do
- fastDebug "Annex.Perms" ("thawing content " ++ fromRawFilePath file)
+ fastDebug "Annex.Perms" ("thawing content " ++ fromOsPath file)
thawPerms (go sr) (thawHook file)
where
go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file
go AllShared = liftIO $ void $ tryIO $ groupWriteRead file
go UnShared = liftIO $ allowWrite file
- go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode file n
+ go (UmaskShared n) = liftIO $ void $ tryIO $
+ R.setFileMode (fromOsPath file) n
{- Runs an action that thaws a file's permissions. This will probably
- fail on a crippled filesystem. But, if file modes are supported on a
- is set, this is not done, since the group must be allowed to delete the
- file without being able to thaw the directory.
-}
-freezeContentDir :: RawFilePath -> Annex ()
+freezeContentDir :: OsPath -> Annex ()
freezeContentDir file = do
- fastDebug "Annex.Perms" ("freezing content directory " ++ fromRawFilePath dir)
+ fastDebug "Annex.Perms" ("freezing content directory " ++ fromOsPath dir)
unlessM crippledFileSystem $ withShared go
freezeHook dir
where
go UnShared = liftIO $ preventWrite dir
go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir
go AllShared = liftIO $ void $ tryIO $ groupWriteRead dir
- go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode dir $
+ go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode (fromOsPath dir) $
umaskSharedDirectory $
- -- If n includes group or other write mode, leave them set
- -- to allow them to delete the file without being able to
- -- thaw the directory.
+ -- If n includes group or other write mode, leave
+ -- them set to allow them to delete the file without
+ -- being able to thaw the directory.
removeModes [ownerWriteMode] n
-thawContentDir :: RawFilePath -> Annex ()
+thawContentDir :: OsPath -> Annex ()
thawContentDir file = do
- fastDebug "Annex.Perms" ("thawing content directory " ++ fromRawFilePath dir)
+ fastDebug "Annex.Perms" ("thawing content directory " ++ fromOsPath dir)
thawPerms (withShared (liftIO . go)) (thawHook dir)
where
dir = parentDir file
go UnShared = allowWrite dir
go GroupShared = allowWrite dir
go AllShared = allowWrite dir
- go (UmaskShared n) = R.setFileMode dir n
+ go (UmaskShared n) = R.setFileMode (fromOsPath dir) n
{- Makes the directory tree to store an annexed file's content,
- with appropriate permissions on each level. -}
-createContentDir :: RawFilePath -> Annex ()
+createContentDir :: OsPath -> Annex ()
createContentDir dest = do
- unlessM (liftIO $ R.doesPathExist dir) $
+ unlessM (liftIO $ doesDirectoryExist dir) $
createAnnexDirectory dir
-- might have already existed with restricted perms
thawHook dir
{- Creates the content directory for a file if it doesn't already exist,
- or thaws it if it does, then runs an action to modify a file in the
- directory, and finally, freezes the content directory. -}
-modifyContentDir :: RawFilePath -> Annex a -> Annex a
+modifyContentDir :: OsPath -> Annex a -> Annex a
modifyContentDir f a = do
createContentDir f -- also thaws it
v <- tryNonAsync a
{- Like modifyContentDir, but avoids creating the content directory if it
- does not already exist. In that case, the action will probably fail. -}
-modifyContentDirWhenExists :: RawFilePath -> Annex a -> Annex a
+modifyContentDirWhenExists :: OsPath -> Annex a -> Annex a
modifyContentDirWhenExists f a = do
thawContentDir f
v <- tryNonAsync a
<||>
(doesAnnexHookExist thawContentAnnexHook)
-freezeHook :: RawFilePath -> Annex ()
+freezeHook :: OsPath -> Annex ()
freezeHook = void . runAnnexPathHook "%path"
freezeContentAnnexHook annexFreezeContentCommand
-thawHook :: RawFilePath -> Annex ()
+thawHook :: OsPath -> Annex ()
thawHook = void . runAnnexPathHook "%path"
thawContentAnnexHook annexThawContentCommand
Right r -> return r
Left err -> warning (UnquotedString err) >> return False
-download :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex Bool
+download :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> OsPath -> U.UrlOptions -> Annex Bool
download meterupdate iv url file uo =
liftIO (U.download meterupdate iv url file uo) >>= \case
Right () -> return True
Left err -> warning (UnquotedString err) >> return False
-download' :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex (Either String ())
+download' :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> OsPath -> U.UrlOptions -> Annex (Either String ())
download' meterupdate iv url file uo =
liftIO (U.download meterupdate iv url file uo)
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Annex.VariantFile where
import Annex.Common
import Utility.Hash
+import qualified Utility.OsString as OS
import qualified Data.ByteString as S
-variantMarker :: String
-variantMarker = ".variant-"
+variantMarker :: OsPath
+variantMarker = literalOsPath ".variant-"
-mkVariant :: FilePath -> String -> FilePath
+mkVariant :: OsPath -> OsPath -> OsPath
mkVariant file variant = takeDirectory file
</> dropExtension (takeFileName file)
- ++ variantMarker ++ variant
- ++ takeExtension file
+ <> variantMarker <> variant
+ <> takeExtension file
{- The filename to use when resolving a conflicted merge of a file,
- that points to a key.
- conflicted merge resolution code. That case is detected, and the full
- key is used in the filename.
-}
-variantFile :: FilePath -> Key -> FilePath
+variantFile :: OsPath -> Key -> OsPath
variantFile file key
- | doubleconflict = mkVariant file (fromRawFilePath (keyFile key))
- | otherwise = mkVariant file (shortHash $ serializeKey' key)
+ | doubleconflict = mkVariant file (keyFile key)
+ | otherwise = mkVariant file (toOsPath (shortHash $ serializeKey' key))
where
- doubleconflict = variantMarker `isInfixOf` file
+ doubleconflict = variantMarker `OS.isInfixOf` file
shortHash :: S.ByteString -> String
shortHash = take 4 . show . md5s
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Annex.View.ViewedFile (
import Annex.Common
import Utility.QuickCheck
import Backend.Utilities (maxExtensions)
+import qualified Utility.OsString as OS
import qualified Data.ByteString as S
type FileName = String
type ViewedFile = FileName
-type MkViewedFile = FilePath -> ViewedFile
+type MkViewedFile = OsPath -> ViewedFile
{- Converts a filepath used in a reference branch to the
- filename that will be used in the view.
viewedFileFromReference' :: Maybe Int -> Maybe Int -> MkViewedFile
viewedFileFromReference' maxextlen maxextensions f = concat $
- [ escape (fromRawFilePath base')
- , if null dirs then "" else "_%" ++ intercalate "%" (map escape dirs) ++ "%"
+ [ escape (fromOsPath base')
+ , if null dirs
+ then ""
+ else "_%" ++ intercalate "%" (map (escape . fromOsPath) dirs) ++ "%"
, escape $ fromRawFilePath $ S.concat extensions'
]
where
(path, basefile) = splitFileName f
- dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path)
+ dirs = filter (/= literalOsPath ".") $
+ map dropTrailingPathSeparator (splitPath path)
(base, extensions) = case maxextlen of
- Nothing -> splitShortExtensions (toRawFilePath basefile')
- Just n -> splitShortExtensions' (n+1) (toRawFilePath basefile')
+ Nothing -> splitShortExtensions basefile'
+ Just n -> splitShortExtensions' (n+1) basefile'
{- Limit number of extensions. -}
maxextensions' = fromMaybe maxExtensions maxextensions
(base', extensions')
| length extensions <= maxextensions' = (base, extensions)
| otherwise =
let (es,more) = splitAt maxextensions' (reverse extensions)
- in (base <> mconcat (reverse more), reverse es)
+ in (base <> toOsPath (mconcat (reverse more)), reverse es)
{- On Windows, if the filename looked like "dir/c:foo" then
- basefile would look like it contains a drive letter, which will
- not work. There cannot really be a filename like that, probably,
{- For use when operating already within a view, so whatever filepath
- is present in the work tree is already a ViewedFile. -}
viewedFileReuse :: MkViewedFile
-viewedFileReuse = takeFileName
+viewedFileReuse = fromOsPath . takeFileName
{- Extracts from a ViewedFile the directory where the file is located on
- in the reference branch. -}
dirFromViewedFile :: ViewedFile -> FilePath
-dirFromViewedFile = joinPath . drop 1 . sep [] ""
+dirFromViewedFile = fromOsPath . joinPath . map toOsPath . drop 1 . sep [] ""
where
sep l _ [] = reverse l
sep l curr (c:cs)
prop_viewedFile_roundtrips :: TestableFilePath -> Bool
prop_viewedFile_roundtrips tf
-- Relative filenames wanted, not directories.
- | any (isPathSeparator) (end f ++ beginning f) = True
- | isAbsolute f || isDrive f = True
- | otherwise = dir == dirFromViewedFile
- (viewedFileFromReference' Nothing Nothing f)
+ | OS.any isPathSeparator (toOsPath (end f ++ beginning f)) = True
+ | isAbsolute (toOsPath f) || isDrive (toOsPath f) = True
+ | otherwise = fromOsPath dir == dirFromViewedFile
+ (viewedFileFromReference' Nothing Nothing (toOsPath f))
where
f = fromTestableFilePath tf
- dir = joinPath $ beginning $ splitDirectories f
+ dir = joinPath $ beginning $ splitDirectories (toOsPath f)
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Assistant.Ssh where
import Annex.Common
{- Reverses genSshUrl -}
parseSshUrl :: String -> Maybe SshData
parseSshUrl u
- | "ssh://" `isPrefixOf` u = fromssh (drop (length "ssh://") u)
+ | "ssh://" `isPrefixOf` u = fromssh (drop (length ("ssh://" :: String)) u)
| otherwise = fromrsync u
where
mkdata (userhost, dir) = Just $ SshData
removeAuthorizedKeys gitannexshellonly dir pubkey = do
let keyline = authorizedKeysLine gitannexshellonly dir pubkey
sshdir <- sshDir
- let keyfile = toOsPath $ toRawFilePath $ sshdir </> "authorized_keys"
+ let keyfile = sshdir </> literalOsPath "authorized_keys"
tryWhenExists (map decodeBS . fileLines' <$> F.readFile' keyfile) >>= \case
Just ls -> viaTmp writeSshConfig keyfile $
unlines $ filter (/= keyline) ls
{- Generates a ssh key pair. -}
genSshKeyPair :: IO SshKeyPair
-genSshKeyPair = withTmpDir (toOsPath (toRawFilePath "git-annex-keygen")) $ \dir -> do
+genSshKeyPair = withTmpDir (literalOsPath "git-annex-keygen") $ \dir -> do
ok <- boolSystem "ssh-keygen"
[ Param "-P", Param "" -- no password
- , Param "-f", File $ dir </> "key"
+ , Param "-f", File $ fromOsPath (dir </> literalOsPath "key")
]
unless ok $
giveup "ssh-keygen failed"
SshKeyPair
- <$> readFile (dir </> "key.pub")
- <*> readFile (dir </> "key")
+ <$> readFile (fromOsPath (dir </> literalOsPath "key.pub"))
+ <*> readFile (fromOsPath (dir </> literalOsPath "key"))
{- Installs a ssh key pair, and sets up ssh config with a mangled hostname
- that will enable use of the key. This way we avoid changing the user's
installSshKeyPair :: SshKeyPair -> SshData -> IO SshData
installSshKeyPair sshkeypair sshdata = do
sshdir <- sshDir
- createDirectoryIfMissing True $ fromRawFilePath $
- parentDir $ toRawFilePath $ sshdir </> sshPrivKeyFile sshdata
+ createDirectoryIfMissing True $
+ parentDir $ sshdir </> sshPrivKeyFile sshdata
unlessM (doesFileExist $ sshdir </> sshPrivKeyFile sshdata) $
- writeFileProtected (toRawFilePath (sshdir </> sshPrivKeyFile sshdata)) (sshPrivKey sshkeypair)
+ writeFileProtected (sshdir </> sshPrivKeyFile sshdata)
+ (sshPrivKey sshkeypair)
unlessM (doesFileExist $ sshdir </> sshPubKeyFile sshdata) $
- writeFile (sshdir </> sshPubKeyFile sshdata) (sshPubKey sshkeypair)
+ writeFile (fromOsPath (sshdir </> sshPubKeyFile sshdata))
+ (sshPubKey sshkeypair)
setSshConfig sshdata
- [ ("IdentityFile", "~/.ssh/" ++ sshPrivKeyFile sshdata)
+ [ ("IdentityFile", "~/.ssh/" ++ fromOsPath (sshPrivKeyFile sshdata))
, ("IdentitiesOnly", "yes")
, ("StrictHostKeyChecking", "yes")
]
-sshPrivKeyFile :: SshData -> FilePath
-sshPrivKeyFile sshdata = "git-annex" </> "key." ++ mangleSshHostName sshdata
+sshPrivKeyFile :: SshData -> OsPath
+sshPrivKeyFile sshdata = literalOsPath "git-annex"
+ </> literalOsPath "key." <> toOsPath (mangleSshHostName sshdata)
-sshPubKeyFile :: SshData -> FilePath
-sshPubKeyFile sshdata = sshPrivKeyFile sshdata ++ ".pub"
+sshPubKeyFile :: SshData -> OsPath
+sshPubKeyFile sshdata = sshPrivKeyFile sshdata <> literalOsPath ".pub"
{- Generates an installs a new ssh key pair if one is not already
- installed. Returns the modified SshData that will use the key pair,
setupSshKeyPair :: SshData -> IO (SshData, SshKeyPair)
setupSshKeyPair sshdata = do
sshdir <- sshDir
- mprivkey <- catchMaybeIO $ readFile (sshdir </> sshPrivKeyFile sshdata)
- mpubkey <- catchMaybeIO $ readFile (sshdir </> sshPubKeyFile sshdata)
+ mprivkey <- catchMaybeIO $ readFile (fromOsPath (sshdir </> sshPrivKeyFile sshdata))
+ mpubkey <- catchMaybeIO $ readFile (fromOsPath (sshdir </> sshPubKeyFile sshdata))
keypair <- case (mprivkey, mpubkey) of
(Just privkey, Just pubkey) -> return $ SshKeyPair
{ sshPubKey = pubkey
setSshConfig sshdata config = do
sshdir <- sshDir
createDirectoryIfMissing True sshdir
- let configfile = sshdir </> "config"
+ let configfile = fromOsPath (sshdir </> literalOsPath "config")
unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $ do
appendFile configfile $ unlines $
[ ""
, "Host " ++ mangledhost
] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v)
(settings ++ config)
- setSshConfigMode (toRawFilePath configfile)
+ setSshConfigMode (toOsPath configfile)
return $ sshdata
{ sshHostName = T.pack mangledhost
knownHost :: Text -> IO Bool
knownHost hostname = do
sshdir <- sshDir
- ifM (doesFileExist $ sshdir </> "known_hosts")
+ ifM (doesFileExist $ sshdir </> literalOsPath "known_hosts")
( not . null <$> checkhost
, return False
)
expected = reverse $ takeWhile (/= '-') $ reverse $
decodeBS $ S.fromShort $ fromKey keyName key
-genGitBundleKey :: UUID -> RawFilePath -> MeterUpdate -> Annex Key
+genGitBundleKey :: UUID -> OsPath -> MeterUpdate -> Annex Key
genGitBundleKey remoteuuid file meterupdate = do
filesize <- liftIO $ getFileSize file
s <- Hash.hashFile hash file meterupdate
keyValue hash source meterupdate
>>= addE source (const $ hashKeyVariety hash (HasExt True))
-checkKeyChecksum :: (Key -> String -> Bool) -> Hash -> Key -> RawFilePath -> Annex Bool
+checkKeyChecksum :: (Key -> String -> Bool) -> Hash -> Key -> OsPath -> Annex Bool
checkKeyChecksum issame hash key file = catchIOErrorType HardwareFault hwfault $ do
showAction (UnquotedString descChecksum)
issame key
AssociatedFile Nothing -> Nothing
AssociatedFile (Just file) -> Just $ alterKey oldkey $ \d -> d
{ keyName = S.toShort $ keyHash oldkey
- <> selectExtension maxextlen maxexts file
+ <> selectExtension maxextlen maxexts (fromOsPath file)
, keyVariety = newvariety
}
{- Upgrade to fix bad previous migration that created a
oldvariety = fromKey keyVariety oldkey
newvariety = backendVariety newbackend
-hashFile :: Hash -> RawFilePath -> MeterUpdate -> Annex String
+hashFile :: Hash -> OsPath -> MeterUpdate -> Annex String
hashFile hash file meterupdate =
- liftIO $ withMeteredFile (fromRawFilePath file) meterupdate $ \b -> do
+ liftIO $ withMeteredFile file meterupdate $ \b -> do
let h = (fst $ hasher hash) b
-- Force full evaluation of hash so whole file is read
-- before returning.
let ext = selectExtension
(annexMaxExtensionLength c)
(annexMaxExtensions c)
- (keyFilename source)
+ (fromOsPath (keyFilename source))
return $ alterKey k $ \d -> d
{ keyName = keyName d <> S.toShort ext
, keyVariety = sethasext (keyVariety d)
keyValue :: KeySource -> MeterUpdate -> Annex Key
keyValue source _ = do
let f = contentLocation source
- stat <- liftIO $ R.getFileStatus f
+ stat <- liftIO $ R.getFileStatus (fromOsPath f)
sz <- liftIO $ getFileSize' f stat
- relf <- fromRawFilePath . getTopFilePath
+ relf <- fromOsPath . getTopFilePath
<$> inRepo (toTopFilePath $ keyFilename source)
return $ mkKey $ \k -> k
{ keyName = genKeyName relf
setCrippledFileSystem b =
setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b)
-pidLockFile :: Annex (Maybe RawFilePath)
+pidLockFile :: Annex (Maybe OsPath)
#ifndef mingw32_HOST_OS
pidLockFile = ifM (annexPidLock <$> Annex.getGitConfig)
( Just <$> Annex.fromRepo gitAnnexPidLockFile
branch = Git.Ref b
subdir = if S.null p
then Nothing
- else Just (asTopFilePath p)
+ else Just (asTopFilePath (toOsPath p))
import qualified Utility.FileIO as F
import qualified Data.ByteString as S
-import qualified System.FilePath.ByteString as P
configureSmudgeFilter :: Annex ()
configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do
gfs <- readattr gf
gittop <- Git.localGitDir <$> gitRepo
liftIO $ unless ("filter=annex" `S.isInfixOf` (lfs <> gfs)) $ do
- createDirectoryUnder [gittop] (P.takeDirectory lf)
- F.writeFile' (toOsPath lf) $
+ createDirectoryUnder [gittop] (takeDirectory lf)
+ F.writeFile' lf $
linesFile' (lfs <> encodeBS ("\n" ++ unlines stdattr))
where
- readattr = liftIO . catchDefaultIO mempty . F.readFile' . toOsPath
+ readattr = liftIO . catchDefaultIO mempty . F.readFile'
configureSmudgeFilterProcess :: Annex ()
configureSmudgeFilterProcess =
deconfigureSmudgeFilter = do
lf <- Annex.fromRepo Git.attributesLocal
ls <- liftIO $ catchDefaultIO [] $
- map decodeBS . fileLines' <$> F.readFile' (toOsPath lf)
- liftIO $ writeFile (fromRawFilePath lf) $ unlines $
+ map decodeBS . fileLines' <$> F.readFile' lf
+ liftIO $ writeFile (fromOsPath lf) $ unlines $
filter (\l -> l `notElem` stdattr && not (null l)) ls
unsetConfig (ConfigKey "filter.annex.smudge")
unsetConfig (ConfigKey "filter.annex.clean")
-- they typically use unix newlines, which does work there
-- and makes the repository more portable.
viaTmp F.writeFile' f (encodeBS (hookScript h))
- void $ tryIO $ modifyFileMode (fromOsPath f) (addModes executeModes)
+ void $ tryIO $ modifyFileMode f (addModes executeModes)
return True
{- Removes a hook. Returns False if the hook contained something else, and
removeLoose s = removeWhenExistsWith R.removeLink $
fromOsPath $ looseObjectFile r s
removeBad s = do
- void $ tryIO $ allowRead $ fromOsPath $ looseObjectFile r s
+ void $ tryIO $ allowRead $ looseObjectFile r s
whenM (isMissing s r) $
removeLoose s
putStrLn "Unpacking all pack files."
forM_ packs $ \packfile -> do
-- Just in case permissions are messed up.
- allowRead (fromOsPath packfile)
+ allowRead packfile
-- May fail, if pack file is corrupt.
void $ tryIO $
pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h ->
writeFile (fromOsPath headfile) "ref: refs/heads/master"
explodePackedRefsFile g
unless (repoIsLocalBare g) $
- void $ tryIO $ allowWrite $ fromOsPath $ indexFile g
+ void $ tryIO $ allowWrite $ indexFile g
where
headfile = localGitDir g </> literalOsPath "HEAD"
validhead s = "ref: refs/" `isPrefixOf` s
safeReadFile :: OsPath -> IO B.ByteString
safeReadFile f = do
- allowRead (fromOsPath f)
+ allowRead f
F.readFile' f
import Types.Key
import Types.KeySource
import Utility.Metered
+import Utility.OsPath
import Utility.FileSystemEncoding
import Utility.Hash (IncrementalVerifier)
, genKey :: Maybe (KeySource -> MeterUpdate -> a Key)
-- Verifies the content of a key, stored in a file, using a hash.
-- This does not need to be cryptographically secure.
- , verifyKeyContent :: Maybe (Key -> RawFilePath -> a Bool)
+ , verifyKeyContent :: Maybe (Key -> OsPath -> a Bool)
-- Incrementally verifies the content of a key, using the same
-- hash as verifyKeyContent, but with the content provided
-- incrementally a piece at a time, until finalized.
module Types.KeySource where
import Utility.InodeCache
-import System.FilePath.ByteString (RawFilePath)
+import Utility.OsPath
{- When content is in the process of being ingested into the annex,
- and a Key generated from it, this data type is used.
- files that may be made while they're in the process of being ingested.
-}
data KeySource = KeySource
- { keyFilename :: RawFilePath
- , contentLocation :: RawFilePath
+ { keyFilename :: OsPath
+ , contentLocation :: OsPath
, inodeCache :: Maybe InodeCache
}
deriving (Show)
(
withFile,
openFile,
+ withBinaryFile,
openBinaryFile,
readFile,
readFile',
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
O.openFile f' m
+withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r
+withBinaryFile f m a = do
+ f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
+ O.withBinaryFile f' m a
+
openBinaryFile :: OsPath -> IOMode -> IO Handle
openBinaryFile f m = do
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
openFile :: OsPath -> IOMode -> IO Handle
openFile = System.IO.openFile . fromRawFilePath
+withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r
+withBinaryFile = System.IO.withBinaryFile . fromRawFilePath
+
openBinaryFile :: OsPath -> IOMode -> IO Handle
openBinaryFile = System.IO.openBinaryFile . fromRawFilePath
import Control.Monad.Catch
import Utility.Exception
-import Utility.FileSystemEncoding
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import Utility.OsPath
{- Applies a conversion function to a file's mode. -}
-modifyFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO ()
+modifyFileMode :: OsPath -> (FileMode -> FileMode) -> IO ()
modifyFileMode f convert = void $ modifyFileMode' f convert
-modifyFileMode' :: RawFilePath -> (FileMode -> FileMode) -> IO FileMode
+modifyFileMode' :: OsPath -> (FileMode -> FileMode) -> IO FileMode
modifyFileMode' f convert = do
- s <- R.getFileStatus f
+ s <- R.getFileStatus f'
let old = fileMode s
let new = convert old
when (new /= old) $
- R.setFileMode f new
+ R.setFileMode f' new
return old
+ where
+ f' = fromOsPath f
{- Runs an action after changing a file's mode, then restores the old mode. -}
-withModifiedFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO a -> IO a
+withModifiedFileMode :: OsPath -> (FileMode -> FileMode) -> IO a -> IO a
withModifiedFileMode file convert a = bracket setup cleanup go
where
setup = modifyFileMode' file convert
]
{- Removes the write bits from a file. -}
-preventWrite :: RawFilePath -> IO ()
+preventWrite :: OsPath -> IO ()
preventWrite f = modifyFileMode f $ removeModes writeModes
{- Turns a file's owner write bit back on. -}
-allowWrite :: RawFilePath -> IO ()
+allowWrite :: OsPath -> IO ()
allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]
{- Turns a file's owner read bit back on. -}
-allowRead :: RawFilePath -> IO ()
+allowRead :: OsPath -> IO ()
allowRead f = modifyFileMode f $ addModes [ownerReadMode]
{- Allows owner and group to read and write to a file. -}
, ownerReadMode, groupReadMode
]
-groupWriteRead :: RawFilePath -> IO ()
+groupWriteRead :: OsPath -> IO ()
groupWriteRead f = modifyFileMode f $ addModes groupSharedModes
checkMode :: FileMode -> FileMode -> Bool
isExecutable :: FileMode -> Bool
isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0
-data ModeSetter = ModeSetter FileMode (RawFilePath -> IO ())
+data ModeSetter = ModeSetter FileMode (OsPath -> IO ())
{- Runs an action which should create the file, passing it the desired
- initial file mode. Then runs the ModeSetter's action on the file, which
- can adjust the initial mode if umask prevented the file from being
- created with the right mode. -}
-applyModeSetter :: Maybe ModeSetter -> RawFilePath -> (Maybe FileMode -> IO a) -> IO a
+applyModeSetter :: Maybe ModeSetter -> OsPath -> (Maybe FileMode -> IO a) -> IO a
applyModeSetter (Just (ModeSetter mode modeaction)) file a = do
r <- a (Just mode)
void $ tryIO $ modeaction file
stickyMode :: FileMode
stickyMode = 512
-setSticky :: RawFilePath -> IO ()
+setSticky :: OsPath -> IO ()
setSticky f = modifyFileMode f $ addModes [stickyMode]
#endif
- On a filesystem that does not support file permissions, this is the same
- as writeFile.
-}
-writeFileProtected :: RawFilePath -> String -> IO ()
+writeFileProtected :: OsPath -> String -> IO ()
writeFileProtected file content = writeFileProtected' file
(\h -> hPutStr h content)
-writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO ()
+writeFileProtected' :: OsPath -> (Handle -> IO ()) -> IO ()
writeFileProtected' file writer = bracket setup cleanup writer
where
setup = do
- h <- protectedOutput $ F.openFile (toOsPath file) WriteMode
+ h <- protectedOutput $ F.openFile file WriteMode
void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
return h
cleanup = hClose
origenviron <- getEnvironment
let environ = addEntry var (fromOsPath subdir) origenviron
-- gpg is picky about permissions on its home dir
- liftIO $ void $ tryIO $ modifyFileMode (fromOsPath subdir) $
+ liftIO $ void $ tryIO $ modifyFileMode subdir $
removeModes $ otherGroupModes
-- For some reason, recent gpg needs a trustdb to be set up.
_ <- pipeStrict' cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] (Just environ) mempty
-- Close on exec flag is set so child processes do not inherit the lock.
openLockFile :: LockRequest -> Maybe ModeSetter -> LockFile -> IO Fd
openLockFile lockreq filemode lockfile = do
- l <- applyModeSetter filemode lockfile' $ \filemode' ->
- openFdWithMode lockfile' openfor filemode' defaultFileFlags
+ l <- applyModeSetter filemode lockfile $ \filemode' ->
+ openFdWithMode (fromOsPath lockfile) openfor filemode' defaultFileFlags
setFdOption l CloseOnExec True
return l
where
- lockfile' = fromOsPath lockfile
openfor = case lockreq of
ReadLock -> ReadOnly
_ -> ReadWrite
import Utility.SimpleProtocol as Proto
import Utility.ThreadScheduler
import Utility.SafeOutput
+import qualified Utility.FileIO as F
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S
{- Sends the content of a file to an action, updating the meter as it's
- consumed. -}
-withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a
-withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h ->
+withMeteredFile :: OsPath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a
+withMeteredFile f meterupdate a = F.withBinaryFile f ReadMode $ \h ->
hGetContentsMetered h meterupdate >>= a
{- Calls the action repeatedly with chunks from the lazy ByteString.
meterupdate sofar'
go sofar' cs
-meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO ()
-meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h ->
+meteredWriteFile :: MeterUpdate -> OsPath -> L.ByteString -> IO ()
+meteredWriteFile meterupdate f b = F.withBinaryFile f WriteMode $ \h ->
meteredWrite meterupdate (S.hPut h) b
{- Applies an offset to a MeterUpdate. This can be useful when
writeSshConfig :: OsPath -> String -> IO ()
writeSshConfig f s = do
F.writeFile' f (linesFile' (encodeBS s))
- setSshConfigMode (fromOsPath f)
+ setSshConfigMode f
{- Ensure that the ssh config file lacks any group or other write bits,
- since ssh is paranoid about not working if other users can write
- If the chmod fails, ignore the failure, as it might be a filesystem like
- Android's that does not support file modes.
-}
-setSshConfigMode :: RawFilePath -> IO ()
+setSshConfigMode :: OsPath -> IO ()
setSshConfigMode f = void $ tryIO $ modifyFileMode f $
removeModes [groupWriteMode, otherWriteMode]
prepHiddenServiceSocketDir appname uid ident = do
createDirectoryIfMissing True d
setOwnerAndGroup (fromOsPath d) uid (-1)
- modifyFileMode (fromOsPath d) $
+ modifyFileMode d $
addModes [ownerReadMode, ownerExecuteMode, ownerWriteMode]
where
d = takeDirectory $ hiddenServiceSocketFile appname uid ident
downloadfile u = do
noverification
- let src = unEscapeString (uriPath u)
+ let src = toOsPath $ unEscapeString (uriPath u)
withMeteredFile src meterupdate $
F.writeFile file
return $ Right ()
projects / git-annex.git / commitdiff